home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
TYPE.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
61KB
|
1,867 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#define GEN
#include "hdr.h"
#include "vars.h"
#include "segment.h"
#include "gvars.h"
#include "attr.h"
#include "ops.h"
#include "type.h"
#include "axqrp.h"
#include "setp.h"
#include "dbxp.h"
#include "initobjp.h"
#include "maincasp.h"
#include "gmainp.h"
#include "arithp.h"
#include "segmentp.h"
#include "genp.h"
#include "exprp.h"
#include "gutilp.h"
#include "arithp.h"
#include "genp.h"
#include "miscp.h"
#include "gmiscp.h"
#include "smiscp.h"
#include "statp.h"
#include "typep.h"
static void init_enum(Symbol, Segment, int, int);
static void install_type(Symbol, Segment, int);
static Segment make_fixed_template(Const, Const, Const, Const,
struct tt_fx_range **);
static void split_powers(int *);
static void process_record(Symbol);
static int linearize_record(Tuple, Node);
static int discr_dep_subtype(Node);
static void get_discr(Node, int *, int *);
static void eval_max_size(Symbol, Tuple);
#define TT_PTR(p) (int **) p
extern Segment CODE_SEGMENT, DATA_SEGMENT, DATA_SEGMENT_MAIN;
extern Segment VARIANT_TABLE, FIELD_TABLE;
extern int ADA_MIN_INTEGER, ADA_MAX_INTEGER;
extern *ADA_MIN_INTEGER_MP, *ADA_MAX_INTEGER_MP;
extern long ADA_MIN_FIXED, ADA_MAX_FIXED;
extern int *ADA_MIN_FIXED_MP, *ADA_MAX_FIXED_MP;
static char *PRECISION_NOT_SUPPORTED =
"Precision not supported by implementation. (Appendix F)";
/* split_ variables use to report result from split_powers()*/
static int split_powers_2, split_powers_5, split_powers_value;
/* Chapter 3: types */
/* type elaboration */
void gen_type(Symbol type_name) /*;gen_type*/
{
/* This is the main procedure for type elaboration.
*
* type_name : in the case of a type declaration, this is the
* name of the type.
*/
Node l_node, u_node, d_node, s_node, low_node, high_node, entry_node;
Node name_node, pragma_id, pragma_list, pragma_op, pragma_val, value_node;
Symbol parent_type, comp_type, typ, entry_name, entry_type, index;
Symbol indx_type, task_proc;
Tuple type_list, index_list, tup, sig, entry_list;
int nb_dim, lng, priority, offset;
long nb_elements, nb_len; /* long to avoid overflow problems */
int family_number, len, global_flag, ubd, lbd;
int collection_size;
Tuple repr_tup;
Const low_const, high_const, delta_const, small_const;
Segment stemplate, static_template, non_static_template;
Fortup ft1;
struct tt_array *tt_array_ptr;
struct tt_e_range *tt_e_range_ptr;
struct tt_access *tt_access_ptr;
struct tt_task *tt_task_ptr;
struct tt_fx_range *tt_fx_range_ptr;
#ifdef TRACE
if (debug_flag)
gen_trace_symbol("GEN_TYPE", type_name);
#endif
switch(NATURE(type_name)) {
case(na_type):
/* Case of FIXED types for which we create a template.
* Also case of derived types.
*/
if (is_fixed_type(type_name)) {
sig = SIGNATURE(type_name);
l_node = (Node) sig[2];
u_node = (Node) sig[3];
d_node = (Node) sig[4];
s_node = (Node) sig[5];
low_const = get_ivalue(l_node);
high_const = get_ivalue(u_node);
delta_const = get_ivalue(d_node);
small_const = get_ivalue(s_node);
stemplate = make_fixed_template(low_const, high_const, delta_const,
small_const, &tt_fx_range_ptr);
/* SETL ver supports 2 kinds of fixed point, in C we have only 1 */
tt_fx_range_ptr->fxlow = ADA_MIN_FIXED + 1;
tt_fx_range_ptr->fxhigh = ADA_MAX_FIXED;
TYPE_KIND(type_name) = TK_LONG;
TYPE_SIZE(type_name) = su_size(TK_LONG);
install_type(type_name, stemplate, TRUE);
root_type(type_name) = type_name;
}
else { /* Derived type */
parent_type = TYPE_OF(type_name);
assign_same_reference(type_name, parent_type);
TYPE_KIND(type_name) = TYPE_KIND(parent_type);
TYPE_SIZE(type_name) = TYPE_SIZE(parent_type);
}
break;
case(na_array):
tup = (Tuple) SIGNATURE(type_name);
index_list = (Tuple) tup[1];
comp_type = (Symbol) tup[2];
if (is_entry_type(comp_type))
return;
nb_dim = tup_size(index_list);
nb_elements = 1L;
FORTUP(index = (Symbol), index_list, ft1);
len = length_of(index);
if (len >= 0)
nb_elements *= len;
else
nb_elements = -1L;
ENDFORTUP(ft1);
if ((nb_elements >= 0L) && has_static_size(comp_type)) {
/* want TYPE_SIZE to be number of storage units for array , */
/* TBSL: check that TYPE_KIND assignment below right,
* as in SETL just have TYPE_SIZE assignment of course
*/
TYPE_KIND(type_name) = TYPE_KIND(comp_type);
nb_len= nb_elements * TYPE_SIZE(comp_type);
if (nb_len > MAX_STATIC_SIZE) nb_len = -1;
TYPE_SIZE(type_name) = nb_len;
}
else {
TYPE_SIZE(type_name) = -1;
}
stemplate = template_new(TT_U_ARRAY, size_of(type_name),
WORDS_ARRAY - 4, TT_PTR(&tt_array_ptr));
/* TBSL: need to define field TT_U_ARRAY_DIMENSIONS: byte or integer? */
tt_array_ptr->dim = nb_dim;
global_flag = has_static_size(type_name);
type_list = tup_copy(index_list);
type_list = (Tuple) tup_with(type_list, (char *) comp_type);
while(tup_size(type_list)) {
typ = (Symbol) tup_frome(type_list);
reference_of(typ);
/* template +:= ref; */
segment_put_int(stemplate, REFERENCE_SEGMENT);
segment_put_int(stemplate, (int) REFERENCE_OFFSET);
global_flag &= is_global(typ);
}
tup_free(type_list);
install_type(type_name, stemplate, global_flag);
break;
case(na_record):
process_record(type_name);
break;
case(na_enum):
/* this one is certainly static... */
sig = SIGNATURE(type_name);
low_node = (Node) sig[2];
high_node = (Node) sig[3];
lbd = get_ivalue_int(low_node);
ubd = get_ivalue_int(high_node);
stemplate = template_new(TT_ENUM, 1, WORDS_E_RANGE,
TT_PTR(&tt_e_range_ptr));
tt_e_range_ptr->elow = lbd;
tt_e_range_ptr->ehigh = ubd;
init_enum(type_name, stemplate, lbd, ubd);
/* TYPE_SIZE(type_name) = ubd <= 255 ? mu_size(mu_byte) :
mu_size(mu_word); */
TYPE_KIND(type_name) = TK_WORD; /* only word case for 1st version */
TYPE_SIZE(type_name) = 1; /* only word case for 1st version ds*/
/* put that in the static segment.... */
install_type(type_name, stemplate, TRUE);
break;
case(na_access):
/* Needs own template, as the accessed type contains a task
* (otherwise expander changed it to derived type from $ACCESS).
*/
TYPE_KIND(type_name) = TYPE_KIND(symbol_daccess);
TYPE_SIZE(type_name) = TYPE_SIZE(symbol_daccess);
stemplate = template_new(TT_ACCESS, size_of(type_name),
WORDS_ACCESS, TT_PTR(&tt_access_ptr));
tt_access_ptr->master_task = 0;
tt_access_ptr->master_bfp = 0;
repr_tup = REPR(type_name);
if (repr_tup == (Tuple)0) /* error condition */
value_node = OPT_NODE;
else
value_node = (Node) repr_tup[3];
if (N_KIND(value_node) == as_opt) {
tt_access_ptr->collection_size = ADA_MAX_INTEGER;
tt_access_ptr->collection_avail = ADA_MAX_INTEGER;
}
else if (N_KIND(value_node) == as_ivalue) {
collection_size = INTV((Const)N_VAL(value_node));
tt_access_ptr->collection_size = collection_size;
tt_access_ptr->collection_avail = collection_size;
}
install_type(type_name, stemplate, FALSE);
if ((N_KIND(value_node) != as_opt) &&
(N_KIND(value_node) != as_ivalue)) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen_kic(I_ADD_IMMEDIATE, mu_word,
WORD_OFF(tt_access, collection_size), "collection size");
gen_value(value_node);
gen_kc(I_MOVE, mu_word, "update collection size");
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen_kic(I_ADD_IMMEDIATE, mu_word,
WORD_OFF(tt_access, collection_avail), "collection avail");
gen_value(value_node);
gen_kc(I_MOVE, mu_word, "update collection avail");
}
break;
case(na_task_type_spec):
case(na_task_type):
entry_list